SuperHack/SuperHack CD.bin/CODING/DELPHI/DELPHCGI.ZIP/CGI.ZIP/SOURCE/CGI.PAS

Pascal/Delphi Source File | 1995-07-13 | 10.3 KB | 342 lines

unit CGI;

interface

uses
    Classes,
    DBTables,
    Forms,
    IniFiles,
    Messages,
    SysUtils,
    WinProcs,
    WinTypes;

type
    TTupleList = class(TStringList)
        private
            function GetKey(const Index: Integer): String;
            function GetInt(const Key: String): LongInt;
        public
           function GetExternalSize(const Key: String): Integer;
           function GetExternalData(const Key: String; var Buffer: PChar): Integer;
            function IndexOfKey(const Key: String): Integer;
            property IntValues[const Key: String]: LongInt read GetInt;
            property Keys[const Index: Integer]: String read GetKey;
    end;

    TCGIProfile = record
        AcceptTypes: TTupleList;
        AuthType: String;
        AuthUser: String;
        ContentFile: String;
        ContentLength: LongInt;
        ContentType: String;
        DebugMode: ByteBool;
        ExecutablePath: String;
        ExtraHeaders: TTupleList;
       GMTOffset: LongInt;
        LogicalPath: String;
        OutputFile: String;
        PhysicalPath: String;
       ProfileFile: String;
        QueryString: String;
        RemoteAddr: String;
        RemoteHost: String;
        RequestMethod: String;
        RequestProtocol: String;
        ServerAdmin: String;
        ServerName: String;
        ServerPort: Integer;
        ServerSoftware: String;
        TAPUser: String;
        Version: String;
    end;

    { Define enumerated request methods for use in case statements }
    TRequestMethod = (rmGet, rmPost, rmTextSearch, rmHead, rmLink, rmUnlink, rmPut, rmOther);
   TServerStatus = (stOK, stCreated, stAccepted, stPartialInfo, stNoResponse,
                    stMoved, stFound, stMethod, stNotModified, stBadRequest,
                    stUnauthorized, stPaymentRequired, stForbidden, stNotFound,
                     stInternalError, stNotImplemented, stOverloaded, stTimeout);

    TCGI = class(TComponent)
        private
           FContentType: String;
            FExternalTuples: TTupleList;
            FFormTuples: TTupleList;
            FHugeTuples: TTupleList;
            FProfile: TCGIProfile;
           FStatus: TServerStatus;
            FStdOut: TMemoryStream;
           FResponseHeaders: TStringList;
            IniFile: TIniFile;

            procedure ErrorProc(Sender: TObject);
           procedure Initialize;
            function TranslateMethod: TRequestMethod;
           procedure ProcessMessages;
        public
            { Methods }
            constructor Create(AOwner: TComponent); override;
           destructor Destroy; override;
            procedure Send(Text: String);
           procedure SendContent;

            { Run-Time Properties }
            property ExternalFields: TTupleList read FExternalTuples;
            property FormFields: TTupleList read FFormTuples;
            property HugeFields: TTupleList read FHugeTuples;
            property Method: TRequestMethod read TranslateMethod;
            property Profile: TCGIProfile read FProfile;

            property ResponseHeaders: TStringList read FResponseHeaders;
           property StdOut: TMemoryStream read FStdOut;
        published
            { Design-Time Properties and Events }
           property ServerStatus: TServerStatus read FStatus write FStatus default stOK;
           property ContentType: String read FContentType write FContentType;
    end;

implementation

constructor TCGI.Create(AOwner: TComponent);
begin
    inherited Create(AOwner);
    with FProfile do begin
        AcceptTypes := TTupleList.Create;
        ExtraHeaders := TTupleList.Create;
    end;
    FFormTuples := TTupleList.Create;
    FExternalTuples := TTupleList.Create;
    FHugeTuples := TTupleList.Create;
   FResponseHeaders := TStringList.Create;
   FStatus := stOK;
   FContentType := 'text/html';

   { If it's run-time, let's load up our data! }
   if not (csDesigning in ComponentState) then    Initialize;
end;

destructor TCGI.Destroy;
begin
    if Assigned(FStdOut) then begin
        FStdOut.Free;
   end;
   inherited Destroy;
end;

procedure TCGI.Initialize;
begin
    with FProfile do begin
        ProfileFile := ParamStr(1);
        OutputFile := ParamStr(3);
        IniFile := TIniFile.Create(ProfileFile);

        { Read CGI and System Information }
        with IniFile do begin
            ServerSoftware := ReadString('CGI','Server Software', '');
            ServerName := ReadString('CGI', 'Server Name', '');
            ServerPort := ReadInteger('CGI', 'Server Port', -1);
            RequestProtocol := ReadString('CGI', 'Request Protocol', '');
            ServerAdmin := ReadString('CGI', 'Server Admin', '');
            Version := ReadString('CGI', 'CGI Version', '');
            RequestMethod := ReadString('CGI', 'Request Method', '');
            LogicalPath := ReadString('CGI', 'Logical Path', '');
            PhysicalPath := ReadString('CGI', 'Physical Path', '');
            ExecutablePath := ReadString('CGI', 'Executable Path', '');
            QueryString := ReadString('CGI', 'Query String', '');
            RemoteHost := ReadString('CGI', 'Remote Host', '');
            RemoteAddr := ReadString('CGI', 'Remote Address', '');
            AuthUser := ReadString('CGI', 'Authenticated User', '');
            TAPUser := ReadString('CGI', 'RFC-931 Identity', '');
            AuthType := ReadString('CGI', 'Authentication Method', '');
            ContentFile := ReadString('System', 'Content File', '');
            ContentType := ReadString('CGI', 'Content Type', '');
            ContentLength := ReadInteger('CGI', 'Content Length', 0);
           GMTOffset := ReadInteger('System', 'GMT Offset', -1);
            DebugMode := (ReadString('System', 'Debug Mode', 'No') = 'Yes');
        end;

        { Open Output File; Get Accept Types and Extra Headers }
        FStdOut := TMemoryStream.Create;
        IniFile.ReadSectionValues('Accept', AcceptTypes);
        IniFile.ReadSectionValues('Extra Headers', ExtraHeaders);
    end;

    { Get Form Data }
    IniFile.ReadSectionValues('Form Literal', FFormTuples);
    IniFile.ReadSectionValues('Form External', FExternalTuples);
    IniFile.ReadSectionValues('Form Huge', FHugeTuples);
    IniFile.Free;

    { Cycle Windows Messages -- Important! It lets the server know we're alive! }
   if Owner = nil then ProcessMessages else Application.ProcessMessages;
end;

procedure TCGI.Send(Text: String);
begin
    FStdOut.Write(Text[1], Byte(Text[0]));
end;

procedure TCGI.SendContent;
var
    StdOutFile: TFileStream;
   Text: String;
   i: Integer;
begin
    StdOutFile := TFileStream.Create(FProfile.OutputFile, fmCreate);

   case FStatus of
    { 2xx SUCCESS }
   stOK:                Text := '200 OK';
   stCreated:            Text := '201 Created';
   stAccepted:            Text := '202 Accepted';
   stPartialInfo:        Text := '203 Partial Information';
   stNoResponse:        Text := '204 No Response';
   { 3xx REDIRECTION }
   stMoved:            Text := '301 Moved';
   stFound:            Text := '302 Found';
   stMethod:            Text := '303 Method';
   stNotModified:        Text := '304 Not Modified';
   { 4xx CLIENT ERROR }
   stBadRequest:        Text := '400 Bad Request';
   stUnauthorized:        Text := '401 Unauthorized';
   stPaymentRequired:    Text := '402 PaymentRequired';
   stForbidden:        Text := '403 Forbidden';
   stNotFound:            Text := '404 Not Found';
   { 5xx SERVER ERROR }
    stInternalError:    Text := '500 Internal Error';
   stNotImplemented:    Text := '501 Not Implemented';
   stOverloaded:        Text := '502 Service Temporarily Overloaded';
   stTimeout:            Text := '503 Gateway Timeout';
    end;
    Text := Text + #13#10;
   StdOutFile.Write(Text[1], Byte(Text[0]));

   Text := 'Content-Type: '+FContentType+#13#10;
   StdOutFile.Write(Text[1], Byte(Text[0]));

   Text := 'Content-Length: '+IntToStr(FStdOut.Size)+#13#10;
   StdOutFile.Write(Text[1], Byte(Text[0]));

    with ResponseHeaders do
        for i := 0 to Count - 1 do begin
           Text := Strings[i]+#13#10;
            StdOutFile.Write(Text[1], Byte(Text[0]));
       end;

   Text := #13#10;
   StdOutFile.Write(Text[1], Byte(Text[0]));
   FStdOut.SaveToStream(StdOutFile);
   StdOutFile.Free;
end;

procedure TCGI.ErrorProc(Sender: TObject);
begin
    with FProfile do begin
        FStdOut.Seek(0,0);
       FStatus := stInternalError;
        Send('<HTML>');
        Send('<HEAD>');
        Send('<TITLE>Error in ' + ExecutablePath + '</TITLE>');
        Send('<H1>Error in ' + ExecutablePath + '</H1>');
        Send('</HEAD>');
        Send('<BODY>');
        Send('An internal error has occurred in ' + ExecutablePath + '.<P>');
        Send('<I>Please</I> note what you were doing when this problem occurred,');
        Send('so we can identify and correct it. Write down the Web page you were using,');
        Send('any data you may have entered into a form or search box, and');
        Send('anything else that may help us duplicate the problem. Then contact the');
        Send('administrator of this service: ');
        Send('<A HREF="mailto:' + ServerAdmin + '">');
        Send('<ADDRESS><' + ServerAdmin + '></ADDRESS>');
        Send('</A></BODY></HTML>');
       SendContent;
       Halt;
    end;
end;

function TCGI.TranslateMethod: TRequestMethod;
const
    RequestMethods: array[Low(TRequestMethod)..High(TRequestMethod)] of String =
               ('GET','POST','TEXTSEARCH','HEAD','LINK','UNLINK','PUT','OTHER');
var
    i: TRequestMethod;
begin
    Result := High(TRequestMethod);
      i := Low(TRequestMethod);
    with FProfile do
        while i < High(TRequestMethod) do begin
            if UpperCase(RequestMethod) = RequestMethods[i] then Result := i;
           Inc(i);
       end;
end;

procedure TCGI.ProcessMessages;
var
    Msg: TMsg;
begin
    while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
       if Msg.Message <> WM_QUIT then begin
            TranslateMessage(Msg);
            DispatchMessage(Msg);
       end else
           Halt;
end;

{ TTupleList implementations }

function TTupleList.GetExternalSize(const Key: String): Integer;
var
    i: Integer;
begin
    i := Pos(' ',Values[Key]);
   Result := StrToInt(Copy(Values[Key],i,Length(Values[Key])-(i-1)));
end;

function TTupleList.GetExternalData(const Key: String; var Buffer: PChar): Integer;
var
    ExtFile, Filename: String;
    i, Size: Integer;
   FileStream: TFileStream;
begin
    ExtFile := Values[Key];
    i := Pos(' ',ExtFile);
   Filename := Copy(ExtFile,1,i);
   System.Delete(ExtFile,1,i);
    Size := StrToInt(ExtFile);

   FileStream := TFileStream.Create(Filename,fmOpenRead);
   if StrBufSize(Buffer) >= Size then
       Result := FileStream.Read(Buffer^,Size)
   else
       Result := 0;
   FileStream.Destroy;
end;

function TTupleList.IndexOfKey(const Key: String): Integer;
var
    i: Integer;
begin
    Result := -1;
    for i := 0 to Count - 1 do
        if GetKey(i) = Key then Result := i;
end;

function TTupleList.GetKey(const Index: Integer): String;
begin
    if Index < Count then
        Result := Copy(Strings[Index],1,Pos('=',Strings[Index])-1)
    else
        Result := '';
end;

function TTupleList.GetInt(const Key: String): LongInt;
begin
    Result := StrToInt(Values[Key]);
end;

end.